home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpwt.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  7.0 KB  |  201 lines
  1. ;;; CMPWT  Output routines.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (eval-when (compile eval)
  25.   (require 'FASDMACROS "../cmpnew/fasdmacros.lsp")
  26.  
  27.  
  28. (defmacro data-vector () `(car *data*))
  29. (defmacro data-inits () `(second *data*))
  30. (defmacro data-package-ops () `(third *data*))
  31.  
  32. )
  33.  
  34. (defun wt-comment (message &optional (symbol nil))
  35.   (princ "
  36. /*    " *compiler-output1*)
  37.   (princ message *compiler-output1*)
  38.   (when symbol
  39.         (let ((s (symbol-name symbol)))
  40.              (declare (string s))
  41.              (dotimes** (n (length s))
  42.                         (let ((c (schar s n)))
  43.                              (declare (character c))
  44.                              (unless (char= c #\/)
  45.                                      (princ c *compiler-output1*))))))
  46.   (princ "    */
  47. " *compiler-output1*)
  48.   nil
  49.   )
  50.  
  51. (defun wt1 (form)
  52.   (cond ((or (stringp form) (integerp form) (characterp form))
  53.          (princ form *compiler-output1*))
  54.         ((or (typep form 'long-float)
  55.              (typep form 'short-float))
  56.          (format *compiler-output1* "~10,,,,,,'eG" form))
  57.         (t (wt-loc form)))
  58.   nil)
  59.  
  60. (defun wt-h1 (form)
  61.   (cond ((consp form)
  62.          (let ((fun (get (car form) 'wt)))
  63.               (if fun
  64.                   (apply fun (cdr form))
  65.                   (cmpiler-error "The location ~s is undefined." form))))
  66.         (t (princ form *compiler-output2*)))
  67.   nil)
  68.  
  69. (defvar *fasd-data*)
  70.  
  71. (defun push-data-incf (x)
  72.   (vector-push-extend (cons (si::hash-equal x -1000) x) (data-vector))
  73.   (incf *next-vv*))
  74.  
  75. (defun wt-data1 (expr)
  76.   (let ((*print-radix* nil)
  77.         (*print-base* 10)
  78.         (*print-circle* t)
  79.         (*print-pretty* nil)
  80.         (*print-level* nil)
  81.         (*print-length* nil)
  82.         (*print-case* :downcase)
  83.         (*print-gensym* t)
  84.         (*print-array* t)
  85.     ;;This forces the printer to add the float type in the .data file.
  86.     (*READ-DEFAULT-FLOAT-FORMAT* t) 
  87.         (si::*print-package* t)
  88.         (si::*print-structure* t))
  89.     (terpri *compiler-output-data*)
  90.     (prin1 expr *compiler-output-data*)))
  91.  
  92. (defun verify-data-vector(vec &aux v)
  93.   (dotimes (i (length vec))
  94.        (setq v (aref vec i))
  95.        (let ((has (si::hash-equal (cdr v) -1000)))
  96.          (cond ((not (eql (car v) has))
  97.             (cmpwarn "A form or constant:~% ~s ~%has changed during the eval compile procedure!.~%  The changed form will be the one put in the compiled file" (cdr v)))))
  98.        (setf (aref vec i) (cdr v)))
  99.   vec
  100.   )
  101.  
  102. (defun add-init (x &optional endp)
  103.   (let ((tem (cons (si::hash-equal x -1000) x)))
  104.     (setf (data-inits)
  105.             (if endp
  106.             (nconc (data-inits) (list tem))
  107.               (cons tem (data-inits) )))
  108.     x))
  109.  
  110. (defun wt-data-file ()
  111.   (verify-data-vector (data-vector))
  112.   (let* ((vec (coerce (nreverse (data-inits)) 'vector)))
  113.     (verify-data-vector vec)
  114.     (setf (aref (data-vector) (- (length (data-vector)) 1))
  115.       (cons 'si::%init vec))
  116.     (setf (data-package-ops) (nreverse (data-package-ops)))
  117.     (cond (*fasd-data*
  118.        (wt-fasd-data-file))
  119.       (t
  120.        (format *compiler-output-data* "       ~%#(")
  121.        (dolist (v (data-package-ops))
  122.            (format *compiler-output-data* "#! ")
  123.            (wt-data1 v))
  124.        (wt-data1 (data-vector))
  125.        (format *compiler-output-data* "~%)~%")
  126.        ))))
  127.  
  128. (defun wt-fasd-data-file ( &aux (x (data-vector)) tem)
  129. ;  (si::find-sharing-top (data-package-ops) (fasd-table (car *fasd-data*)))
  130.   (si::find-sharing-top x (fasd-table (car *fasd-data*)))
  131.   (cond ((setq tem  (data-package-ops))
  132.      (dolist (v tem)
  133.      (put-op d_eval_skip  *compiler-output-data*)
  134.      (si::write-fasd-top v (car *fasd-data*)))))
  135.   (si::write-fasd-top x (car *fasd-data*))
  136. ;  (sloop::sloop for (k v) in-table (fasd-table (car *fasd-data*))
  137. ;        when (>= v 0) do (print (list k v)))
  138.   (si::close-fasd (car *fasd-data*)))
  139. (defun wt-data-begin ())
  140. (defun wt-data-end ())
  141. (defun wt-data-package-operation (x)
  142.   (push x (data-package-ops)))
  143.  
  144. (defmacro wt (&rest forms &aux (fl nil))
  145.   (dolist** (form forms (cons 'progn (reverse (cons nil fl))))
  146.     (if (stringp form)
  147.         (push `(princ ,form *compiler-output1*) fl)
  148.         (push `(wt1 ,form) fl))))
  149.  
  150. (defmacro wt-h (&rest forms &aux (fl nil))
  151.   (cond ((endp forms) '(princ "
  152. " *compiler-output2*))
  153.         ((stringp (car forms))
  154.          (dolist** (form (cdr forms)
  155.                          (list* 'progn `(princ ,(concatenate 'string "
  156. " (car forms)) *compiler-output2*) (reverse (cons nil fl))))
  157.                    (if (stringp form)
  158.                        (push `(princ ,form *compiler-output2*) fl)
  159.                        (push `(wt-h1 ,form) fl))))
  160.         (t (dolist** (form forms
  161.                            (list* 'progn '(princ "
  162. " *compiler-output2*) (reverse (cons nil fl))))
  163.                      (if (stringp form)
  164.                          (push `(princ ,form *compiler-output2*) fl)
  165.                          (push `(wt-h1 ,form) fl))))))
  166.  
  167. (defmacro wt-nl (&rest forms &aux (fl nil))
  168.   (cond ((endp forms) '(princ "
  169.     " *compiler-output1*))
  170.         ((stringp (car forms))
  171.          (dolist** (form (cdr forms)
  172.                          (list* 'progn `(princ ,(concatenate 'string "
  173.     " (car forms)) *compiler-output1*) (reverse (cons nil fl))))
  174.                    (if (stringp form)
  175.                        (push `(princ ,form *compiler-output1*) fl)
  176.                        (push `(wt1 ,form) fl))))
  177.         (t (dolist** (form forms
  178.                            (list* 'progn '(princ "
  179.     " *compiler-output1*) (reverse (cons nil fl))))
  180.                      (if (stringp form)
  181.                          (push `(princ ,form *compiler-output1*) fl)
  182.                          (push `(wt1 ,form) fl))))))
  183.  
  184. (defmacro wt-nl1 (&rest forms &aux (fl nil))
  185.   (cond ((endp forms) '(princ "
  186. " *compiler-output1*))
  187.         ((stringp (car forms))
  188.          (dolist** (form (cdr forms)
  189.                          (list* 'progn `(princ ,(concatenate 'string "
  190. " (car forms)) *compiler-output1*) (reverse (cons nil fl))))
  191.                    (if (stringp form)
  192.                        (push `(princ ,form *compiler-output1*) fl)
  193.                        (push `(wt1 ,form) fl))))
  194.         (t (dolist** (form forms
  195.                            (list* 'progn '(princ "
  196. " *compiler-output1*) (reverse (cons nil fl))))
  197.                      (if (stringp form)
  198.                          (push `(princ ,form *compiler-output1*) fl)
  199.                          (push `(wt1 ,form) fl))))))
  200.  
  201.